Over 1,000 Windows 95 Programs/Over 1000 Windows 95 Programs (Microforum) (Disc 1).iso/1138/source.zip/PAPERBOY.BAS

BASIC Source File | 1995-05-16 | 16.8 KB | 494 lines

Option Explicit
' Global variables
Global PaperboyVersion As String
Global INIfile As String
Global Group As Integer
Global Message As Integer
Global mailsendto As String
Global mailsubject As String
Global mailreferences As String
Global replytype As Integer '1=mail, 2=news
Global Persist As Integer 'Remember position from previous packet

' Windows API used by program
Declare Function GetWinFlags Lib "Kernel" () As Long
Global Const WF_CPU286 = &H2
Declare Function GetProfileInt% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal nDefault%)
Declare Function GetProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%)
Declare Function WriteProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpString$)
Declare Function GetPrivateProfileInt% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal nDefault%, ByVal lpFileName$)
Declare Function GetPrivateProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpreturned$, ByVal nSize%, ByVal lpFileName$)
Declare Function WritePrivateProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpString$, ByVal lpFileName$)
Declare Function lstrcpy Lib "Kernel" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function GetModuleUsage% Lib "Kernel" (ByVal hModule%)

' Paperboy/SOUP support DLL API
Global Const ERRMEM = 10
Global Const ERRIO = 20
Global Const ERRPARSE = 30

Global Const NUMFOLDERS = 20

Type finder
    Group As Integer
    Message As Integer
    lineno As Integer
End Type

Declare Function InitSOUPDLL% Lib "PBOYSOUP.DLL" ()
Declare Function MajorVersion% Lib "PBOYSOUP.DLL" ()
Declare Function MinorVersion% Lib "PBOYSOUP.DLL" ()
Declare Function VersionDesc Lib "PBOYSOUP.DLL" () As Long
Declare Function LoadAreas Lib "PBOYSOUP.DLL" (ByVal fname As String) As Integer
Declare Function GetNumAreas Lib "PBOYSOUP.DLL" () As Integer
Declare Function GetAreaName Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Long
Declare Function GetAreaEncoding Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Long
Declare Function GetAreaDesc Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Long
Declare Function GetNumMsgs Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Integer
Declare Function ThreadMsgs Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Integer
Declare Function GetSubject Lib "PBOYSOUP.DLL" (ByVal index As Integer, ByVal index2 As Integer) As Long
Declare Function GetLength Lib "PBOYSOUP.DLL" (ByVal index As Integer, ByVal index2 As Integer) As Long
Declare Function GetAuthor Lib "PBOYSOUP.DLL" (ByVal index As Integer, ByVal index2 As Integer) As Long
Declare Function GetNumLines Lib "PBOYSOUP.DLL" () As Integer
Declare Function GetLine Lib "PBOYSOUP.DLL" (ByVal lineno As Integer) As Long
Declare Function GetInfo Lib "PBOYSOUP.DLL" () As Integer
Declare Function Post Lib "PBOYSOUP.DLL" (ByVal fname As String, ByVal sendtype As Integer) As Integer
Declare Function GetHeader Lib "PBOYSOUP.DLL" (ByVal header As String) As Long
Declare Function GetGMTime Lib "PBOYSOUP.DLL" () As Long
Declare Sub GetMsg Lib "PBOYSOUP.DLL" (ByVal index1 As Integer, ByVal index2 As Integer)
Declare Sub Rot13Msg Lib "PBOYSOUP.DLL" ()
Declare Sub reclaimareas Lib "PBOYSOUP.DLL" ()
Declare Function IsFolder Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Integer
Declare Function LoadFolder Lib "PBOYSOUP.DLL" (ByVal foldername As String, ByVal folderfile As String, ByVal folderdesc As String) As Integer
Declare Sub CreateNewMsg Lib "PBOYSOUP.DLL" ()
Declare Function AddLineToMsg Lib "PBOYSOUP.DLL" (ByVal newline As String) As Integer
Declare Sub RemoveArea Lib "PBOYSOUP.DLL" (ByVal foldername As String)
Declare Function SaveMsgToFolder Lib "PBOYSOUP.DLL" (ByVal filename As String) As Integer
Declare Function DeleteMsg Lib "PBOYSOUP.DLL" (ByVal areaindex As Integer, ByVal msgindex As Integer) As Integer
Declare Function Find Lib "PBOYSOUP.DLL" (begin As finder, ByVal srchstring As String) As Integer
Declare Function GetErrorText Lib "PBOYSOUP.DLL" () As Long

Sub CheckCPU ()
    Dim cputype As Long

    ' Check for CPU > 286
    cputype = GetWinFlags()
    If cputype And WF_CPU286 Then
        ' Paperboy DLL uses 386 instructions, warn user now
        MsgBox "Paperboy requires a 386SX or greater processor.", MB_OK + MB_ICONSTOP, "Warning!"
        End
    End If
End Sub

Sub CreateFolder (foldername As String)
Dim folderfile As String
Dim filenum As Integer
Dim foldernum As Integer

    If foldername = "" Then Exit Sub

    ' See if folder already exists
    For foldernum = 1 To NUMFOLDERS
        If GetINI("Folders", "Name" + Format$(foldernum), "") = foldername Then
            Exit Sub
        End If
    Next foldernum
    foldernum = 1

    ' Find a blank folder slot
    screen.MousePointer = HourGlass
    frmmain.lstsubjects.Enabled = False
    foldernum = 1
    While GetINI("Folders", "Name" + Format$(foldernum), "") <> ""
        foldernum = foldernum + 1
    Wend
    If foldernum > NUMFOLDERS Then
        MsgBox "Too many folders", 0, "Warning!"
    Else
        ' Create the folder
        SetINI "Folders", "Name" + Format$(foldernum), foldername
        ' Create folder file
        folderfile = app.Path + "\FOLDER" + Format$(foldernum) + ".FOL"
        filenum = FreeFile
        Open folderfile For Append As filenum
        Close filenum
    End If

    ' Reread folders
    DoFolders

End Sub

Sub DllErr (ByVal result As Integer)
Dim continue As Integer
Dim msgstr As String

    msgstr = fixstr(GetErrorText())
    If result > 0 And result < 100 Then
        If result = ERRMEM Then
            continue = MsgBox(msgstr + Chr$(10) + "Restart to assure reliable operation" + Chr(10) + "Continue?", MB_YESNO + MB_DEFBUTTON1 + MB_ICONSTOP, "PBOYSOUP.DLL: Out of Memory")
        End If
        If result = ERRIO Then
            continue = MsgBox(msgstr + Chr$(10) + "Reliability may suffer, continue?", MB_YESNO + MB_DEFBUTTON2 + MB_ICONSTOP, "PBOYSOUP.DLL: File format error")
        End If
        If result = ERRPARSE Then
            continue = MsgBox(msgstr + Chr$(10) + "Reliability may suffer, continue?", MB_YESNO + MB_DEFBUTTON2 + MB_ICONSTOP, "PBOYSOUP.DLL: Incompatible file format")
        End If
        If continue = IDNO Then
            frmmain.Hide     ' This should end sub main
        End If
    End If
End Sub

Sub DoFolders ()
Dim foldernum As Integer
Dim foldername As String
Dim folderfile As String
Dim result As Integer

    screen.MousePointer = HourGlass
    For foldernum = 1 To NUMFOLDERS
        foldername = GetINI("Folders", "Name" + Format$(foldernum), "")
        If foldername <> "" Then
            folderfile = app.Path + "\FOLDER" + Format$(foldernum) + ".FOL"
            result = LoadFolder(foldername, folderfile, "Paperboy folder")
            DllErr result
        End If
    Next foldernum

    Call ShowAreas

    screen.MousePointer = default
End Sub

Function endofheaders ()
Dim firstline As Integer

    'Skip headers
    firstline = 1
    While firstline < GetNumLines() And Len(fixstr(GetLine(firstline))) > 0
        firstline = firstline + 1
    Wend

    'Skip the gap
    While firstline < GetNumLines() And Len(fixstr(GetLine(firstline))) = 0
        firstline = firstline + 1
    Wend

    endofheaders = firstline
End Function

Function extractusername (from As String) As String
Dim username As String
Dim pos As Integer

    username = Trim(from) 'Remove leading and trailing spaces

' First type is of [e-mail] (john q. public)
    If InStr(username, "(") > 0 Then
        pos = InStr(username, "(")
        ' Remove everything before (, up to )
        username = Mid$(username, pos + 1)
        username = Left$(username, InStr(username, ")") - 1)
    ElseIf InStr(username, Chr(34)) > 0 Then
    ' [e-mail] "john q. public"
        pos = InStr(username, Chr(34))
        username = Mid$(username, pos)
        ' Truncate past second quote
        username = Left$(username, InStr(username, Chr(34)) - 1)
    ElseIf InStr(username, "<") > 0 Then
    ' John Q. Public <[e-mail]>
        pos = InStr(username, "<")
        username = Left$(username, pos - 1)
    ElseIf InStr(username, "@") > 0 Then
    ' worst-case, [e-mail]
        pos = InStr(username, "@")
        username = Left$(username, pos - 1)
    End If

    ' If parsing gave us nothing, punt
    username = Trim(username)
    If Len(username) = 0 Then username = from
    extractusername = username
End Function

Function FileExists (fname As String) As Integer
'Dim fout As Integer
    'fout = FreeFile
    'On Error Resume Next
    'Open fname For Input As fout
    'If Err = 0 Then
        'Close fout
        'FileExists = 1
    'Else
        'FileExists = 0
    'End If
    If Dir$(fname) = "" Then FileExists = 0 Else FileExists = -1
End Function

Function fixstr (ByVal az As Long) As String
Static tempstr  As String * 1000
Dim z As Integer

If az <> 0 Then
    az = lstrcpy(tempstr, az)
    z = InStr(tempstr, Chr(0)) 'Chop off null-terminator
    If z > 0 Then fixstr = Left$(tempstr, z - 1) Else fixstr = tempstr
Else fixstr = ""
End If
End Function

Function GetINI (ByVal section As String, ByVal key As String, ByVal defvalue As String) As String
Dim result As Integer
Dim newvalue As String
Static hold As String * 200 'Holding place for returned string

    result = GetPrivateProfileString(section, key, "xYzZy", hold, 199, INIfile)
    'Chop off null-terminator
    result = InStr(hold, Chr(0))
    If result > 0 Then newvalue = Left$(hold, result - 1) Else newvalue = hold

    If newvalue = "xYzZy" Then
        ' Write default out to INI file so user knows what's going on
        result = WritePrivateProfileString(section, key, defvalue, INIfile)
        newvalue = defvalue
    End If

    While Left$(newvalue, 1) = " "
        newvalue = Mid$(newvalue, 2) 'Remove trailing spaces
    Wend

    GetINI = newvalue
End Function

Function intmax (ByVal a As Integer, ByVal b As Integer) As Integer
    If a >= b Then intmax = a Else intmax = b
End Function

Function intmin (ByVal a As Integer, ByVal b As Integer) As Integer
    If a <= b Then intmin = a Else intmin = b
End Function

Sub LoadMenuOptions ()

    If UCase$(GetINI("Display", "FixedPitch", "N")) = "N" Then
        frmmain.mnufixedpitch.Checked = False
    Else
        frmmain.mnufixedpitch.Checked = True
    End If

    If UCase$(GetINI("Display", "ShowHeaders", "N")) = "N" Then
        frmmain.mnushowheaders.Checked = False
    Else
        frmmain.mnushowheaders.Checked = True
    End If

    If UCase$(GetINI("Display", "ShowLengths", "N")) = "N" Then
        frmmain.mnushowlengths.Checked = False
    Else
        frmmain.mnushowlengths.Checked = True
    End If

End Sub

Sub Main ()
    Dim lpstr As Long
    Dim result As Integer
    Dim hold As String * 100

    PaperboyVersion = "2.06"

    ' Go to Paperboy's EXE directory
    ChDir app.Path
    ChDrive app.Path

    If app.PrevInstance = True Then
        MsgBox "Only one Paperboy can be active.", MB_ICONSTOP, "Sorry"
        End
    End If

    ' Fire up the DLL
    result = InitSOUPDLL()
    If result <> 0 Then
        MsgBox "Cannot initialize PBOYSOUP.DLL", MB_ICONEXCLAMATION, "InitSOUPDLL()"
        End
    End If

    INIfile = "PAPERBOY.INI"
    'INIfile = App.Path + "\PAPERBOY.INI"
    SetINI "Paperboy", "Copyright", "(C) 1995, Michael H. Vartanian ([e-mail])"
    SetINI "Paperboy", "License", "Paperboy is protected by the GNU public license, see the file COPYING included with Paperboy"

    'Check Version
    If MajorVersion() <> 2 Or MinorVersion() <> 6 Then
        MsgBox "Wrong version of PBOYSOUP.DLL", MB_ICONSTOP, "Installation Error"
        End
    End If

    If GetINI("Window", "Maximized", "N") = "N" Then
        frmmain.WindowState = NORMAL
    Else
        frmmain.WindowState = MAXIMIZED
    End If

    Call LoadMenuOptions

    frmmain.Height = Val(GetINI("Window", "Height", screen.Height * .9))
    frmmain.Width = Val(GetINI("Window", "Width", screen.Width * .9))
    frmmain.Left = Val(GetINI("Window", "Left", (screen.Width - frmmain.Width) \ 2))
    frmmain.Top = Val(GetINI("Window", "Top", (screen.Height - frmmain.Height) \ 2))

    frmmain!lstareas.FontName = GetINI("Fonts", "GroupsName", "Arial")
    frmmain!lstareas.FontSize = Val(GetINI("Fonts", "GroupsSize", "10"))
    frmmain!lstsubjects.FontName = GetINI("Fonts", "SubjName", "Arial")
    frmmain!lstsubjects.FontSize = Val(GetINI("Fonts", "SubjSize", "10"))

    ' Handle Folders
    Call DoFolders

    ' If command-line, assume it's the AREAS filename
    If Len(Command$) > 1 Then
        OpenAreas (Command$)
    End If

    If FileExists("REPLIES") Then
        MsgBox "Don't forget to upload your replies packet." + Chr(13) + Chr(10) + "(pkzip UPLOADME.ZIP REPLIES. PB*.MSG)", MB_OK + MB_ICONINFORMATION, "REPLIES file found!"
    End If

    frmmain.Show Modal
    ' frmmain has quit, shut down

    SetINI "Files", "LastGroupRead", Format$(Group)
    SetINI "Files", "LastMessageRead", Format$(Message)
    End
End Sub

Sub OpenAreas (filename As String)
Dim result, continue, count As Integer
Dim workdir As String
Dim unzip As String
Dim x As Integer

    frmmain.mnuFOPEN.Enabled = False

    screen.MousePointer = HourGlass

    If UCase$(Right$(filename, 3)) = "ZIP" Then
    ' We got a ZIP packet to deal with
        workdir = GetINI("Files", "Packet Directory", app.Path)
        unzip = GetINI("Files", "Unzipper", "pkunzip -o -ere")
        unzip = unzip + " " + filename + " " + workdir
        'ChDrive workdir
        'ChDir workdir
        x = Shell(unzip, 6)
        MsgBox "Press when complete...", 0, unzip
        filename = workdir + "\AREAS."
        If Not FileExists(filename) Then
            frmmain.mnuFOPEN.Enabled = True
            MsgBox "Couldn't extract packet", 0, "Error during unzip"
            screen.MousePointer = default
            Exit Sub
        End If
    End If

    result = LoadAreas(filename)
    screen.MousePointer = default

    DllErr result

    If GetInfo() = 0 Then
        ' We got something urgent to show
        frminfo.Show 1
    End If

    Call ShowAreas

End Sub

Sub SaveFiletoFolder (fname As String, folder As String)
Dim foldernum As Integer
Dim folderfile As String
Dim foldername As String
Dim filenum As Integer
Dim textline As String
Dim result As Integer

    folderfile = ""
    For foldernum = 1 To NUMFOLDERS
        foldername = GetINI("Folders", "Name" + Format$(foldernum), "")
        If foldername = folder Then
            folderfile = app.Path + "\FOLDER" + Format$(foldernum) + ".FOL"
        End If
    Next foldernum

    If folderfile <> "" Then
    ' Save file fname to folder folderfile
        Call CreateNewMsg
        filenum = FreeFile
        Open fname For Input As filenum
        While Not EOF(filenum)
            Line Input #filenum, textline
            result = AddLineToMsg(textline)
        Wend
        Close filenum
        result = SaveMsgToFolder(folderfile)
        DllErr result
        'MsgBox "Saved to " + folderfile
    End If

    ' Reread folders
    DoFolders

End Sub

Sub SetINI (ByVal section As String, ByVal key As String, ByVal value As String)
    'Sets an INI attribute
Dim result As Integer

    INIfile = "PAPERBOY.INI"
    While Left$(value, 1) = " "
        value = Mid$(value, 2) 'Remove trailing spaces
    Wend
    result = WritePrivateProfileString(section, key, value, INIfile)

End Sub

Sub ShowAreas ()
Dim count As Integer
Dim groupname As String
Dim hold, grp, msg As Integer

    frmmain.lstareas.Clear
    frmmain.lstsubjects.Clear
    For count = 1 To GetNumAreas()
        groupname = fixstr(GetAreaName(count))
        frmmain.lstareas.AddItem groupname
    Next count
    frmmain.lstareas.Enabled = True
    grp = Val(GetINI("Files", "LastGroupRead", "0")) - 1
    msg = Val(GetINI("Files", "LastMessageRead", "0")) - 1
    If Persist = True Then
        Persist = False
        hold = MsgBox("Should I put you at the last read message?", MB_ICONQUESTION Or MB_YESNO, "Previously viewed packet")
        If hold = IDYES Then
            If grp >= 0 Then frmmain.lstareas.ListIndex = grp
            If msg >= 0 Then frmmain.lstsubjects.ListIndex = msg
        End If
    End If
End Sub

Function stripfilename (filename As String) As String
Dim lastbackslash, p As Integer

    For p = 1 To Len(filename)
        If Mid$(filename, p, 1) = "\" Then lastbackslash = p
    Next p

    If lastbackslash > 1 Then
        stripfilename = Left$(filename, lastbackslash - 1)
    Else
        stripfilename = "\"
    End If
End Function